home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1995 January / macformat-020.iso / Shareware City / Developers / SIOD 3.0 / sliba.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-10-01  |  24.1 KB  |  918 lines  |  [TEXT/ttxt]
  1. /*  
  2.  *                   COPYRIGHT (c) 1988-1994 BY                             *
  3.  *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  4.  *        See the source file SLIB.C for more information.                  *
  5.  
  6. Array-hacking code moved to another source file.
  7.  
  8. */
  9.  
  10. #include <stdio.h>
  11. #include <string.h>
  12. #include <setjmp.h>
  13. #include <stdlib.h>
  14. #include <ctype.h>
  15.  
  16. #include "siod.h"
  17. #include "siodp.h"
  18.  
  19. LISP bashnum = NIL;
  20.  
  21. void init_storage_a1(long type)
  22. {long j;
  23.  struct user_type_hooks *p;
  24.  set_gc_hooks(type,
  25.           array_gc_relocate,
  26.           array_gc_mark,
  27.           array_gc_scan,
  28.           array_gc_free,
  29.           &j);
  30.  set_print_hooks(type,array_prin1);
  31.  p = get_user_type_hooks(type);
  32.  p->fast_print = array_fast_print;
  33.  p->fast_read = array_fast_read;
  34.  p->equal = array_equal;
  35.  p->c_sxhash = array_sxhash;}
  36.  
  37. void init_storage_a(void)
  38. {gc_protect(&bashnum);
  39.  bashnum = newcell(tc_flonum);
  40.  init_storage_a1(tc_string);
  41.  init_storage_a1(tc_double_array);
  42.  init_storage_a1(tc_long_array);
  43.  init_storage_a1(tc_lisp_array);}
  44.  
  45. LISP array_gc_relocate(LISP ptr)
  46. {LISP nw;
  47.  if ((nw = heap) >= heap_end) gc_fatal_error();
  48.  heap = nw+1;
  49.  memcpy(nw,ptr,sizeof(struct obj));
  50.  return(nw);}
  51.  
  52. void array_gc_scan(LISP ptr)
  53. {long j;
  54.  if TYPEP(ptr,tc_lisp_array)
  55.    for(j=0;j < ptr->storage_as.lisp_array.dim; ++j)
  56.      ptr->storage_as.lisp_array.data[j] =     
  57.        gc_relocate(ptr->storage_as.lisp_array.data[j]);}
  58.  
  59. LISP array_gc_mark(LISP ptr)
  60. {long j;
  61.  if TYPEP(ptr,tc_lisp_array)
  62.    for(j=0;j < ptr->storage_as.lisp_array.dim; ++j)
  63.      gc_mark(ptr->storage_as.lisp_array.data[j]);
  64.  return(NIL);}
  65.  
  66. void array_gc_free(LISP ptr)
  67. {switch (ptr->type)
  68.    {case tc_string:
  69.       free(ptr->storage_as.string.data);
  70.       break;
  71.     case tc_double_array:
  72.       free(ptr->storage_as.double_array.data);
  73.       break;
  74.     case tc_long_array:
  75.       free(ptr->storage_as.long_array.data);
  76.       break;
  77.     case tc_lisp_array:
  78.       free(ptr->storage_as.lisp_array.data);
  79.       break;}}
  80.  
  81. void array_prin1(LISP ptr,FILE *f)
  82. {int j;
  83.  switch (ptr->type)
  84.    {case tc_string:
  85.       fput_st(f,"\"");
  86.       fput_st(f,ptr->storage_as.string.data);
  87.       fput_st(f,"\"");
  88.       break;
  89.     case tc_double_array:
  90.       fput_st(f,"#(");
  91.       for(j=0; j < ptr->storage_as.double_array.dim; ++j)
  92.     {sprintf(tkbuffer,"%g",ptr->storage_as.double_array.data[j]);
  93.      fput_st(f,tkbuffer);
  94.      if ((j + 1) < ptr->storage_as.double_array.dim)
  95.        fput_st(f," ");}
  96.       fput_st(f,")");
  97.       break;
  98.     case tc_long_array:
  99.       fput_st(f,"#(");
  100.       for(j=0; j < ptr->storage_as.long_array.dim; ++j)
  101.     {sprintf(tkbuffer,"%ld",ptr->storage_as.long_array.data[j]);
  102.      fput_st(f,tkbuffer);
  103.      if ((j + 1) < ptr->storage_as.long_array.dim)
  104.        fput_st(f," ");}
  105.       fput_st(f,")");
  106.       break;
  107.     case tc_lisp_array:
  108.       fput_st(f,"#(");
  109.       for(j=0; j < ptr->storage_as.lisp_array.dim; ++j)
  110.     {lprin1f(ptr->storage_as.lisp_array.data[j],f);
  111.      if ((j + 1) < ptr->storage_as.lisp_array.dim)
  112.        fput_st(f," ");}
  113.       fput_st(f,")");
  114.       break;}}
  115.  
  116. LISP strcons(long length,char *data)
  117. {long flag;
  118.  LISP s;
  119.  flag = no_interrupt(1);
  120.  s = cons(NIL,NIL);
  121.  s->type = tc_string;
  122.  s->storage_as.string.data = must_malloc(length+1);
  123.  s->storage_as.string.dim = length;
  124.  if (data)
  125.    {memcpy(s->storage_as.string.data,data,length);
  126.     s->storage_as.string.data[length] = 0;}
  127.  no_interrupt(flag);
  128.  return(s);}
  129.  
  130. int rfs_getc(unsigned char **p)
  131. {int i;
  132.  i = **p;
  133.  if (!i) return(EOF);
  134.  *p = *p + 1;
  135.  return(i);}
  136.  
  137. void rfs_ungetc(unsigned char c,unsigned char **p)
  138. {*p = *p - 1;}
  139.  
  140. LISP read_from_string(LISP x)
  141. {char *p;
  142.  struct gen_readio s;
  143.  p = get_c_string(x);
  144.  s.getc_fcn = (int (*)(char *))rfs_getc;
  145.  s.ungetc_fcn = (void (*)(int, char *))rfs_ungetc;
  146.  s.cb_argument = (char *) &p;
  147.  return(readtl(&s));}
  148.  
  149. LISP aref1(LISP a,LISP i)
  150. {long k;
  151.  if NFLONUMP(i) err("bad index to aref",i);
  152.  k = (long) FLONM(i);
  153.  if (k < 0) err("negative index to aref",i);
  154.  switch (a->type)
  155.    {case tc_string:
  156.       if (k >= a->storage_as.string.dim) err("index too large",i);
  157.       return(flocons((double) a->storage_as.string.data[k]));
  158.     case tc_double_array:
  159.       if (k >= a->storage_as.double_array.dim) err("index too large",i);
  160.       return(flocons(a->storage_as.double_array.data[k]));
  161.     case tc_long_array:
  162.       if (k >= a->storage_as.long_array.dim) err("index too large",i);
  163.       return(flocons(a->storage_as.long_array.data[k]));
  164.     case tc_lisp_array:
  165.       if (k >= a->storage_as.lisp_array.dim) err("index too large",i);
  166.       return(a->storage_as.lisp_array.data[k]);
  167.     default:
  168.       return(err("invalid argument to aref",a));}}
  169.  
  170. void err1_aset1(LISP i)
  171. {err("index to aset too large",i);}
  172.  
  173. void err2_aset1(LISP v)
  174. {err("bad value to store in array",v);}
  175.  
  176. LISP aset1(LISP a,LISP i,LISP v)
  177. {long k;
  178.  if NFLONUMP(i) err("bad index to aset",i);
  179.  k = (long) FLONM(i);
  180.  if (k < 0) err("negative index to aset",i);
  181.  switch (a->type)
  182.    {case tc_string:
  183.       if NFLONUMP(v) err2_aset1(v);
  184.       if (k >= a->storage_as.string.dim) err1_aset1(i);
  185.       a->storage_as.string.data[k] = (char) FLONM(v);
  186.       return(v);
  187.     case tc_double_array:
  188.       if NFLONUMP(v) err2_aset1(v);
  189.       if (k >= a->storage_as.double_array.dim) err1_aset1(i);
  190.       a->storage_as.double_array.data[k] = FLONM(v);
  191.       return(v);
  192.     case tc_long_array:
  193.       if NFLONUMP(v) err2_aset1(v);
  194.       if (k >= a->storage_as.long_array.dim) err1_aset1(i);
  195.       a->storage_as.long_array.data[k] = (long) FLONM(v);
  196.       return(v);
  197.     case tc_lisp_array:
  198.       if (k >= a->storage_as.lisp_array.dim) err1_aset1(i);
  199.       a->storage_as.lisp_array.data[k] = v;
  200.       return(v);
  201.     default:
  202.       return(err("invalid argument to aset",a));}}
  203.  
  204. LISP cons_array(LISP dim,LISP kind)
  205. {LISP a;
  206.  long flag,n,j;
  207.  if (NFLONUMP(dim) || (FLONM(dim) < 0))
  208.    return(err("bad dimension to cons-array",dim));
  209.  else
  210.    n = (long) FLONM(dim);
  211.  flag = no_interrupt(1);
  212.  a = cons(NIL,NIL);
  213.  if EQ(cintern("double"),kind)
  214.    {a->type = tc_double_array;
  215.     a->storage_as.double_array.dim = n;
  216.     a->storage_as.double_array.data = (double *) must_malloc(n *
  217.                                  sizeof(double));
  218.     for(j=0;j<n;++j) a->storage_as.double_array.data[j] = 0.0;}
  219.  else if EQ(cintern("long"),kind)
  220.    {a->type = tc_long_array;
  221.     a->storage_as.long_array.dim = n;
  222.     a->storage_as.long_array.data = (long *) must_malloc(n * sizeof(long));
  223.     for(j=0;j<n;++j) a->storage_as.long_array.data[j] = 0;}
  224.  else if EQ(cintern("string"),kind)
  225.    {a->type = tc_string;
  226.     a->storage_as.double_array.dim = n+1;
  227.     a->storage_as.string.data = (char *) must_malloc(n+1);
  228.     a->storage_as.string.data[n] = 0;
  229.     for(j=0;j<n;++j) a->storage_as.string.data[j] = ' ';}
  230.  else if (EQ(cintern("lisp"),kind) || NULLP(kind))
  231.    {a->type = tc_lisp_array;
  232.     a->storage_as.lisp_array.dim = n;
  233.     a->storage_as.lisp_array.data = (LISP *) must_malloc(n * sizeof(LISP));
  234.     for(j=0;j<n;++j) a->storage_as.lisp_array.data[j] = NIL;}
  235.  else
  236.    err("bad type of array",kind);
  237.  no_interrupt(flag);
  238.  return(a);}
  239.  
  240. LISP string_append(LISP args)
  241. {long size;
  242.  LISP l,s;
  243.  char *data;
  244.  size = 0;
  245.  for(l=args;NNULLP(l);l=cdr(l))
  246.    size += strlen(get_c_string(car(l)));
  247.  s = strcons(size,NULL);
  248.  data = s->storage_as.string.data;
  249.  data[0] = 0;
  250.  for(l=args;NNULLP(l);l=cdr(l))
  251.    strcat(data,get_c_string(car(l)));
  252.  return(s);}
  253.  
  254. LISP substring(LISP str,LISP start,LISP end)
  255. {long s,e,n;
  256.  if NTYPEP(str,tc_string) err("not a string",str);
  257.  n = str->storage_as.string.dim;
  258.  s = get_c_long(start);
  259.  if NULLP(end)
  260.    e = n;
  261.  else
  262.    e = get_c_long(end);
  263.  if ((s < 0) || (s > e)) err("bad start index",start);
  264.  if ((e < 0) || (e > n)) err("bad end index",end);
  265.  return(strcons(e-s,&str->storage_as.string.data[s]));}
  266.  
  267. LISP string_search(LISP token,LISP str)
  268. {char *s1,*s2,*ptr;
  269.  s1 = get_c_string(str);
  270.  s2 = get_c_string(token);
  271.  ptr = strstr(s1,s2);
  272.  if (ptr)
  273.    return(flocons(ptr - s1));
  274.  else
  275.    return(NIL);}
  276.  
  277. LISP string_trim(LISP str)
  278. {char *start,*end;
  279.  start = get_c_string(str);
  280.  while(*start && (*start == ' ')) ++start;
  281.  end = &start[strlen(start)];
  282.  while((end > start) && (*(end-1) == ' ')) --end;
  283.  return(strcons(end-start,start));}
  284.  
  285. LISP string_trim_left(LISP str)
  286. {char *start,*end;
  287.  start = get_c_string(str);
  288.  while(*start && (*start == ' ')) ++start;
  289.  end = &start[strlen(start)];
  290.  return(strcons(end-start,start));}
  291.  
  292. LISP string_trim_right(LISP str)
  293. {char *start,*end;
  294.  start = get_c_string(str);
  295.  end = &start[strlen(start)];
  296.  while((end > start) && (*(end-1) == ' ')) --end;
  297.  return(strcons(end-start,start));}
  298.  
  299. LISP string_upcase(LISP str)
  300. {LISP result;
  301.  char *s1,*s2;
  302.  long j,n;
  303.  s1 = get_c_string(str);
  304.  n = strlen(s1);
  305.  result = strcons(n,s1);
  306.  s2 = get_c_string(result);
  307.  for(j=0;j<n;++j) s2[j] = toupper(s2[j]);
  308.  return(result);}
  309.  
  310. LISP string_downcase(LISP str)
  311. {LISP result;
  312.  char *s1,*s2;
  313.  long j,n;
  314.  s1 = get_c_string(str);
  315.  n = strlen(s1);
  316.  result = strcons(n,s1);
  317.  s2 = get_c_string(result);
  318.  for(j=0;j<n;++j) s2[j] = tolower(s2[j]);
  319.  return(result);}
  320.  
  321. LISP lreadstring(struct gen_readio *f)
  322. {int j,c,n;
  323.  char *p;
  324.  j = 0;
  325.  p = tkbuffer;
  326.  while(((c = GETC_FCN(f)) != '"') && (c != EOF))
  327.    {if (c == '\\')
  328.       {c = GETC_FCN(f);
  329.        if (c == EOF) err("eof after \\",NIL);
  330.        switch(c)
  331.      {case 'n':
  332.         c = '\n';
  333.         break;
  334.       case 't':
  335.         c = '\t';
  336.         break;
  337.       case 'r':
  338.         c = '\r';
  339.         break;
  340.       case 'd':
  341.         c = 0x04;
  342.         break;
  343.       case 'N':
  344.         c = 0;
  345.         break;
  346.       case 's':
  347.         c = ' ';
  348.         break;
  349.       case '0':
  350.         n = 0;
  351.         while(1)
  352.           {c = GETC_FCN(f);
  353.            if (c == EOF) err("eof after \\0",NIL);
  354.            if (isdigit(c))
  355.          n = n * 8 + c - '0';
  356.            else
  357.          {UNGETC_FCN(c,f);
  358.           break;}}
  359.         c = n;}}
  360.     if ((j + 1) >= TKBUFFERN) err("read string overflow",NIL);
  361.     ++j;
  362.     *p++ = c;}
  363.  *p = 0;
  364.  return(strcons(j,tkbuffer));}
  365.  
  366. #define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod))
  367.  
  368. long c_sxhash(LISP obj,long n)
  369. {long hash;
  370.  unsigned char *s;
  371.  LISP tmp;
  372.  struct user_type_hooks *p;
  373.  STACK_CHECK(&obj);
  374.  INTERRUPT_CHECK();
  375.  switch TYPE(obj)
  376.    {case tc_nil:
  377.       return(0);
  378.     case tc_cons:
  379.       hash = c_sxhash(CAR(obj),n);
  380.       for(tmp=CDR(obj);CONSP(tmp);tmp=CDR(tmp))
  381.     hash = HASH_COMBINE(hash,c_sxhash(CAR(tmp),n),n);
  382.       hash = HASH_COMBINE(hash,c_sxhash(tmp,n),n);
  383.       return(hash);
  384.     case tc_symbol:
  385.       for(hash=0,s=(unsigned char *)PNAME(obj);*s;++s)
  386.     hash = HASH_COMBINE(hash,*s,n);
  387.       return(hash);
  388.     case tc_subr_0:
  389.     case tc_subr_1:
  390.     case tc_subr_2:
  391.     case tc_subr_3:
  392.     case tc_lsubr:
  393.     case tc_fsubr:
  394.     case tc_msubr:
  395.       for(hash=0,s=(unsigned char *) obj->storage_as.subr.name;*s;++s)
  396.     hash = HASH_COMBINE(hash,*s,n);
  397.       return(hash);
  398.     case tc_flonum:
  399.       return(((unsigned long)FLONM(obj)) % n);
  400.     default:
  401.       p = get_user_type_hooks(TYPE(obj));
  402.       if (p->c_sxhash)
  403.     return((*p->c_sxhash)(obj,n));
  404.       else
  405.     return(0);}}
  406.  
  407. LISP sxhash(LISP obj,LISP n)
  408. {return(flocons(c_sxhash(obj,FLONUMP(n) ? (long) FLONM(n) : 10000)));}
  409.  
  410. LISP equal(LISP a,LISP b)
  411. {struct user_type_hooks *p;
  412.  long atype;
  413.  STACK_CHECK(&a);
  414.  loop:
  415.  INTERRUPT_CHECK();
  416.  if EQ(a,b) return(truth);
  417.  atype = TYPE(a);
  418.  if (atype != TYPE(b)) return(NIL);
  419.  switch(atype)
  420.    {case tc_cons:
  421.       if NULLP(equal(car(a),car(b))) return(NIL);
  422.       a = cdr(a);
  423.       b = cdr(b);
  424.       goto loop;
  425.     case tc_flonum:
  426.       return((FLONM(a) == FLONM(b)) ? truth : NIL);
  427.     case tc_symbol:
  428.       return(NIL);
  429.     default:
  430.       p = get_user_type_hooks(atype);
  431.       if (p->equal)
  432.     return((*p->equal)(a,b));
  433.       else
  434.     return(NIL);}}
  435.  
  436. LISP array_equal(LISP a,LISP b)
  437. {long j,len;
  438.  switch(TYPE(a))
  439.    {case tc_string:
  440.       len = a->storage_as.string.dim;
  441.       if (len != b->storage_as.string.dim) return(NIL);
  442.       if (memcmp(a->storage_as.string.data,b->storage_as.string.data,len) == 0)
  443.     return(truth);
  444.       else
  445.     return(NIL);
  446.     case tc_long_array:
  447.       len = a->storage_as.long_array.dim;
  448.       if (len != b->storage_as.long_array.dim) return(NIL);
  449.       if (memcmp(a->storage_as.long_array.data,
  450.          b->storage_as.long_array.data,
  451.          len * sizeof(long)) == 0)
  452.     return(truth);
  453.       else
  454.     return(NIL);
  455.     case tc_double_array:
  456.       len = a->storage_as.double_array.dim;
  457.       if (len != b->storage_as.double_array.dim) return(NIL);
  458.       for(j=0;j<len;++j)
  459.     if (a->storage_as.double_array.data[j] !=
  460.         b->storage_as.double_array.data[j])
  461.       return(NIL);
  462.       return(truth);
  463.     case tc_lisp_array:
  464.       len = a->storage_as.lisp_array.dim;
  465.       if (len != b->storage_as.lisp_array.dim) return(NIL);
  466.       for(j=0;j<len;++j)
  467.     if NULLP(equal(a->storage_as.lisp_array.data[j],
  468.                b->storage_as.lisp_array.data[j]))
  469.       return(NIL);
  470.       return(truth);
  471.     default:
  472.       return(errswitch());}}
  473.  
  474. long array_sxhash(LISP a,long n)
  475. {long j,len,hash;
  476.  unsigned char *char_data;
  477.  unsigned long *long_data;
  478.  double *double_data;
  479.  switch(TYPE(a))
  480.    {case tc_string:
  481.       len = a->storage_as.string.dim;
  482.       for(j=0,hash=0,char_data=(unsigned char *)a->storage_as.string.data;
  483.       j < len;
  484.       ++j,++char_data)
  485.     hash = HASH_COMBINE(hash,*char_data,n);
  486.       return(hash);
  487.     case tc_long_array:
  488.       len = a->storage_as.long_array.dim;
  489.       for(j=0,hash=0,long_data=(unsigned long *)a->storage_as.long_array.data;
  490.       j < len;
  491.       ++j,++long_data)
  492.     hash = HASH_COMBINE(hash,*long_data % n,n);
  493.       return(hash);
  494.     case tc_double_array:
  495.       len = a->storage_as.double_array.dim;
  496.       for(j=0,hash=0,double_data=a->storage_as.double_array.data;
  497.       j < len;
  498.       ++j,++double_data)
  499.     hash = HASH_COMBINE(hash,(unsigned long)*double_data % n,n);
  500.       return(hash);
  501.     case tc_lisp_array:
  502.       len = a->storage_as.lisp_array.dim;
  503.       for(j=0,hash=0; j < len; ++j)
  504.     hash = HASH_COMBINE(hash,
  505.                 c_sxhash(a->storage_as.lisp_array.data[j],n),
  506.                 n);
  507.       return(hash);
  508.     default:
  509.       errswitch();
  510.       return(0);}}
  511.  
  512. long href_index(LISP table,LISP key)
  513. {long index;
  514.  if NTYPEP(table,tc_lisp_array) err("not a hash table",table);
  515.  index = c_sxhash(key,table->storage_as.lisp_array.dim);
  516.  if ((index < 0) || (index >= table->storage_as.lisp_array.dim))
  517.    {err("sxhash inconsistency",table);
  518.     return(0);}
  519.  else
  520.    return(index);}
  521.  
  522. LISP href(LISP table,LISP key)
  523. {return(cdr(assoc(key,
  524.           table->storage_as.lisp_array.data[href_index(table,key)])));}
  525.  
  526. LISP hset(LISP table,LISP key,LISP value)
  527. {long index;
  528.  LISP cell,l;
  529.  index = href_index(table,key);
  530.  l = table->storage_as.lisp_array.data[index];
  531.  if NNULLP(cell = assoc(key,l))
  532.    return(setcdr(cell,value));
  533.  cell = cons(key,value);
  534.  table->storage_as.lisp_array.data[index] = cons(cell,l);
  535.  return(value);}
  536.  
  537. LISP assoc(LISP x,LISP alist)
  538. {LISP l,tmp;
  539.  for(l=alist;CONSP(l);l=CDR(l))
  540.    {tmp = CAR(l);
  541.     if (CONSP(tmp) && equal(CAR(tmp),x)) return(tmp);
  542.     INTERRUPT_CHECK();}
  543.  if EQ(l,NIL) return(NIL);
  544.  return(err("improper list to assoc",alist));}
  545.  
  546. void put_long(long i,FILE *f)
  547. {fwrite(&i,sizeof(long),1,f);}
  548.  
  549. long get_long(FILE *f)
  550. {long i;
  551.  fread(&i,sizeof(long),1,f);
  552.  return(i);}
  553.  
  554. long fast_print_table(LISP obj,LISP table)
  555. {FILE *f;
  556.  LISP ht,index;
  557.  f = get_c_file(car(table),(FILE *) NULL);
  558.  if NULLP(ht = car(cdr(table)))
  559.    return(1);
  560.  index = href(ht,obj);
  561.  if NNULLP(index)
  562.    {putc(FO_fetch,f);
  563.     put_long(get_c_long(index),f);
  564.     return(0);}
  565.  if NULLP(index = car(cdr(cdr(table))))
  566.    return(1);
  567.  hset(ht,obj,index);
  568.  FLONM(bashnum) = 1.0;
  569.  setcar(cdr(cdr(table)),plus(index,bashnum));
  570.  putc(FO_store,f);
  571.  put_long(get_c_long(index),f);
  572.  return(1);}
  573.  
  574. LISP fast_print(LISP obj,LISP table)
  575. {FILE *f;
  576.  long len;
  577.  LISP tmp;
  578.  struct user_type_hooks *p;
  579.  STACK_CHECK(&obj);
  580.  f = get_c_file(car(table),(FILE *) NULL);
  581.  switch(TYPE(obj))
  582.    {case tc_nil:
  583.       putc(tc_nil,f);
  584.       return(NIL);
  585.     case tc_cons:
  586.       for(len=0,tmp=obj;CONSP(tmp);tmp=CDR(tmp)) {INTERRUPT_CHECK();++len;}
  587.       if (len == 1)
  588.     {putc(tc_cons,f);
  589.      fast_print(car(obj),table);
  590.      fast_print(cdr(obj),table);}
  591.       else if NULLP(tmp)
  592.     {putc(FO_list,f);
  593.      put_long(len,f);
  594.      for(tmp=obj;CONSP(tmp);tmp=CDR(tmp))
  595.        fast_print(CAR(tmp),table);}
  596.       else
  597.     {putc(FO_listd,f);
  598.      put_long(len,f);
  599.      for(tmp=obj;CONSP(tmp);tmp=CDR(tmp))
  600.        fast_print(CAR(tmp),table);
  601.      fast_print(tmp,table);}
  602.       return(NIL);
  603.     case tc_flonum:
  604.       putc(tc_flonum,f);
  605.       fwrite(&obj->storage_as.flonum.data,
  606.          sizeof(obj->storage_as.flonum.data),
  607.          1,
  608.          f);
  609.       return(NIL);
  610.     case tc_symbol:
  611.       if (fast_print_table(obj,table))
  612.     {putc(tc_symbol,f);
  613.      len = strlen(PNAME(obj));
  614.      if (len >= TKBUFFERN)
  615.        err("symbol name too long",obj);
  616.      put_long(len,f);
  617.      fwrite(PNAME(obj),len,1,f);
  618.      return(truth);}
  619.       else
  620.     return(NIL);
  621.     default:
  622.       p = get_user_type_hooks(TYPE(obj));
  623.       if (p->fast_print)
  624.     return((*p->fast_print)(obj,table));
  625.       else
  626.     return(err("cannot fast-print",obj));}}
  627.  
  628. LISP fast_read(LISP table)
  629. {FILE *f;
  630.  LISP tmp,l;
  631.  struct user_type_hooks *p;
  632.  int c;
  633.  long len;
  634.  f = get_c_file(car(table),(FILE *) NULL);
  635.  c = getc(f);
  636.  if (c == EOF) return(table);
  637.  switch(c)
  638.    {case FO_fetch:
  639.       len = get_long(f);
  640.       FLONM(bashnum) = len;
  641.       return(href(car(cdr(table)),bashnum));
  642.     case FO_store:
  643.       len = get_long(f);
  644.       tmp = fast_read(table);
  645.       hset(car(cdr(table)),flocons(len),tmp);
  646.       return(tmp);
  647.     case tc_nil:
  648.       return(NIL);
  649.     case tc_cons:
  650.       tmp = fast_read(table);
  651.       return(cons(tmp,fast_read(table)));
  652.     case FO_list:
  653.     case FO_listd:
  654.       len = get_long(f);
  655.       FLONM(bashnum) = len;
  656.       l = make_list(bashnum,NIL);
  657.       tmp = l;
  658.       while(len > 1)
  659.     {CAR(tmp) = fast_read(table);
  660.      tmp = CDR(tmp);
  661.      --len;}
  662.       CAR(tmp) = fast_read(table);
  663.       if (c == FO_listd)
  664.     CDR(tmp) = fast_read(table);
  665.       return(l);
  666.     case tc_flonum:
  667.       tmp = newcell(tc_flonum);
  668.       fread(&tmp->storage_as.flonum.data,
  669.         sizeof(tmp->storage_as.flonum.data),
  670.         1,
  671.         f);
  672.       return(tmp);
  673.     case tc_symbol:
  674.       len = get_long(f);
  675.       if (len >= TKBUFFERN)
  676.     err("symbol name too long",NIL);
  677.       fread(tkbuffer,len,1,f);
  678.       tkbuffer[len] = 0;
  679.       return(rintern(tkbuffer));
  680.     default:
  681.       p = get_user_type_hooks(c);
  682.       if (p->fast_read)
  683.     return(*p->fast_read)(c,table);
  684.       else
  685.     return(err("unknown fast-read opcode",flocons(c)));}}
  686.  
  687. LISP array_fast_print(LISP ptr,LISP table)
  688. {int j,len;
  689.  FILE *f;
  690.  f = get_c_file(car(table),(FILE *) NULL);
  691.  switch (ptr->type)
  692.    {case tc_string:
  693.       putc(tc_string,f);
  694.       len = ptr->storage_as.string.dim;
  695.       put_long(len,f);
  696.       fwrite(ptr->storage_as.string.data,len,1,f);
  697.       return(NIL);
  698.     case tc_double_array:
  699.       putc(tc_double_array,f);
  700.       len = ptr->storage_as.double_array.dim * sizeof(double);
  701.       put_long(len,f);
  702.       fwrite(ptr->storage_as.double_array.data,len,1,f);
  703.       return(NIL);
  704.     case tc_long_array:
  705.       putc(tc_long_array,f);
  706.       len = ptr->storage_as.long_array.dim * sizeof(long);
  707.       put_long(len,f);
  708.       fwrite(ptr->storage_as.long_array.data,len,1,f);
  709.       return(NIL);
  710.     case tc_lisp_array:
  711.       putc(tc_lisp_array,f);
  712.       len = ptr->storage_as.lisp_array.dim;
  713.       put_long(len,f);
  714.       for(j=0; j < len; ++j)
  715.     fast_print(ptr->storage_as.lisp_array.data[j],table);
  716.       return(NIL);
  717.     default:
  718.       return(errswitch());}}
  719.  
  720. LISP array_fast_read(int code,LISP table)
  721. {long j,len,iflag;
  722.  FILE *f;
  723.  LISP ptr;
  724.  f = get_c_file(car(table),(FILE *) NULL);
  725.  switch (code)
  726.    {case tc_string:
  727.       len = get_long(f);
  728.       ptr = strcons(len,NULL);
  729.       fread(ptr->storage_as.string.data,len,1,f);
  730.       ptr->storage_as.string.data[len] = 0;
  731.       return(ptr);
  732.     case tc_double_array:
  733.       len = get_long(f);
  734.       iflag = no_interrupt(1);
  735.       ptr = newcell(tc_double_array);
  736.       ptr->storage_as.double_array.dim = len;
  737.       ptr->storage_as.double_array.data =
  738.     (double *) must_malloc(len * sizeof(double));
  739.       fread(ptr->storage_as.double_array.data,sizeof(double),len,f);
  740.       no_interrupt(iflag);
  741.       return(ptr);
  742.     case tc_long_array:
  743.       len = get_long(f);
  744.       iflag = no_interrupt(1);
  745.       ptr = newcell(tc_long_array);
  746.       ptr->storage_as.long_array.dim = len;
  747.       ptr->storage_as.long_array.data =
  748.     (long *) must_malloc(len * sizeof(long));
  749.       fread(ptr->storage_as.long_array.data,sizeof(long),len,f);
  750.       no_interrupt(iflag);
  751.       return(ptr);
  752.     case tc_lisp_array:
  753.       len = get_long(f);
  754.       FLONM(bashnum) = len;
  755.       ptr = cons_array(bashnum,NIL);
  756.       for(j=0; j < len; ++j)
  757.     ptr->storage_as.lisp_array.data[j] = fast_read(table);
  758.       return(ptr);
  759.     default:
  760.       return(errswitch());}}
  761.  
  762. long get_c_long(LISP x)
  763. {if NFLONUMP(x) err("not a number",x);
  764.  return((long)FLONM(x));}
  765.  
  766. LISP make_list(LISP x,LISP v)
  767. {long n;
  768.  LISP l;
  769.  n = get_c_long(x);
  770.  l = NIL;
  771.  while(n > 0)
  772.    {l = cons(v,l); --n;}
  773.  return(l);}
  774.  
  775. LISP lfread(LISP size,LISP file)
  776. {long flag,n,ret,m;
  777.  char *buffer;
  778.  LISP s;
  779.  FILE *f;
  780.  f = get_c_file(file,NULL);
  781.  flag = no_interrupt(1);
  782.  if TYPEP(size,tc_string)
  783.    {s = size;
  784.     buffer = s->storage_as.string.data;
  785.     n = s->storage_as.string.dim;
  786.     m = 0;}
  787.  else
  788.    {n = get_c_long(size);
  789.     buffer = (char *) must_malloc(n+1);
  790.     buffer[n] = 0;
  791.     m = 1;}
  792.  ret = fread(buffer,1,n,f);
  793.  if (ret == 0)
  794.    {if (m)
  795.       free(buffer);
  796.     no_interrupt(flag);
  797.     return(NIL);}
  798.  if (m)
  799.    {if (ret == n)
  800.       {s = cons(NIL,NIL);
  801.        s->type = tc_string;
  802.        s->storage_as.string.data = buffer;
  803.        s->storage_as.string.dim = n;}
  804.     else
  805.       {s = strcons(ret,NULL);
  806.        memcpy(s->storage_as.string.data,buffer,ret);
  807.        free(buffer);}
  808.     no_interrupt(flag);
  809.     return(s);}
  810.  no_interrupt(flag);
  811.  return(flocons((double)ret));}
  812.  
  813. LISP lfwrite(LISP string,LISP file)
  814. {FILE *f;
  815.  long flag;
  816.  char *data;
  817.  long dim;
  818.  f = get_c_file(file,NULL);
  819.  if NTYPEP(string,tc_string) err("not a string",string);
  820.  data = string->storage_as.string.data;
  821.  dim = string->storage_as.string.dim;
  822.  flag = no_interrupt(1);
  823.  fwrite(data,dim,1,f);
  824.  no_interrupt(flag);
  825.  return(NIL);}
  826.  
  827.  
  828. LISP string_length(LISP string)
  829. {if NTYPEP(string,tc_string) err("not a string",string);
  830.  return(flocons((double)string->storage_as.string.dim));}
  831.  
  832. LISP llength(LISP obj)
  833. {LISP l;
  834.  long n;
  835.  switch TYPE(obj)
  836.    {case tc_string:
  837.       return(flocons(obj->storage_as.string.dim));
  838.     case tc_double_array:
  839.       return(flocons(obj->storage_as.double_array.dim));
  840.     case tc_long_array:
  841.       return(flocons(obj->storage_as.long_array.dim));
  842.     case tc_lisp_array:
  843.       return(flocons(obj->storage_as.lisp_array.dim));
  844.     case tc_nil:
  845.       return(flocons(0.0));
  846.     case tc_cons:
  847.       for(l=obj,n=0;CONSP(l);l=CDR(l),++n) INTERRUPT_CHECK();
  848.       if NNULLP(l) err("improper list to length",obj);
  849.       return(flocons(n));
  850.     default:
  851.       return(err("wta to length",obj));}}
  852.  
  853. LISP number2string(LISP x,LISP b)
  854. {char buffer[100];
  855.  double y;
  856.  long base;
  857.  if NFLONUMP(x) err("wta",x);
  858.  y = FLONM(x);
  859.  if NULLP(b)
  860.    sprintf(buffer,"%g",y);
  861.  else if ((base = get_c_long(b)) == 10)
  862.    sprintf(buffer,"%ld",(long)y);
  863.  else if (base == 8)
  864.    sprintf(buffer,"%lo",(long)y);
  865.  else if (base == 16)
  866.    sprintf(buffer,"%lX",(long)y);
  867.  else
  868.    err("number base not handled",b);
  869.  return(strcons(strlen(buffer),buffer));}
  870.  
  871. LISP string2number(LISP x,LISP b)
  872. {char *str;
  873.  long base,value = 0;
  874.  double result;
  875.  str = get_c_string(x);
  876.  if NULLP(b)
  877.    result = atof(str);
  878.  else if ((base = get_c_long(b)) == 10)
  879.    {sscanf(str,"%ld",&value);
  880.     result = (double) value;}
  881.  else if (base == 8)
  882.    {sscanf(str,"%lo",&value);
  883.     result = (double) value;}
  884.  else if (base == 16)
  885.    {sscanf(str,"%lx",&value);
  886.     result = (double) value;}
  887.  else
  888.    err("number base not handled",b);
  889.  return(flocons(result));}
  890.  
  891. void init_subrs_a(void)
  892. {init_subr_2("aref",aref1);
  893.  init_subr_3("aset",aset1);
  894.  init_lsubr("string-append",string_append);
  895.  init_subr_1("string-length",string_length);
  896.  init_subr_1("read-from-string",read_from_string);
  897.  init_subr_2("cons-array",cons_array);
  898.  init_subr_2("sxhash",sxhash);
  899.  init_subr_2("equal?",equal);
  900.  init_subr_2("href",href);
  901.  init_subr_3("hset",hset);
  902.  init_subr_2("assoc",assoc);
  903.  init_subr_1("fast-read",fast_read);
  904.  init_subr_2("fast-print",fast_print);
  905.  init_subr_2("make-list",make_list);
  906.  init_subr_2("fread",lfread);
  907.  init_subr_2("fwrite",lfwrite);
  908.  init_subr_1("length",llength);
  909.  init_subr_2("number->string",number2string);
  910.  init_subr_2("string->number",string2number);
  911.  init_subr_3("substring",substring);
  912.  init_subr_2("string-search",string_search);
  913.  init_subr_1("string-trim",string_trim);
  914.  init_subr_1("string-trim-left",string_trim_left);
  915.  init_subr_1("string-trim-right",string_trim_right);
  916.  init_subr_1("string-upcase",string_upcase);
  917.  init_subr_1("string-downcase",string_downcase);}
  918.